home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / pascal / tpsqapi1.zip / STRLIB.PAS < prev   
Pascal/Delphi Source File  |  1992-02-13  |  13KB  |  544 lines
  1. {$A-}
  2. Unit STRLIB;
  3.  
  4.  
  5. Interface
  6.  
  7. TYPE  str1      =  string[1];   str2      =  string[2];
  8.       str3      =  string[3];   str4      =  string[4];
  9.       str5      =  string[5];   str6      =  string[6];
  10.       str7      =  string[7];   str8      =  string[8];
  11.       str9      =  string[9];   str10     =  string[10];
  12.       str11     =  string[11];  str12     =  string[12];
  13.       str13     =  string[13];  str14     =  string[14];
  14.       str15     =  string[15];  str16     =  string[16];
  15.       str17     =  string[17];  str19     =  string[19];
  16.       str20     =  string[20];  str22     =  string[22];
  17.       str23     =  string[23];  str24     =  string[24];
  18.       str25     =  string[25];  str26     =  string[26];
  19.       str30     =  string[30];  str31     =  string[31];
  20.       str32     =  string[32];  str33     =  string[33];
  21.       str35     =  string[35];  str38     =  string[38];
  22.       str39     =  string[39];  str40     =  string[40];
  23.       str41     =  string[41];  str42     =  string[42];
  24.       str43     =  string[43];  str45     =  string[45];
  25.       str48     =  string[48];  str49     =  string[49];
  26.       str46     =  string[46];  str50     =  string[50];
  27.       str52     =  string[52];  str55     =  string[55];
  28.       str60     =  string[60];  str63     =  string[63];
  29.       str65     =  string[65];  str66     =  string[66];
  30.       str70     =  string[70];  str71     =  string[71];
  31.       str72     =  string[72];  str73     =  string[73];
  32.       str75     =  string[75];  str76     =  string[76];
  33.       str79     =  string[79];  str80     =  string[80];
  34.       str81     =  string[81];  str132    =  string[132];
  35.       str255    =  string[255];
  36.  
  37. FUNCTION RemoveLB(Instr:string):string;
  38. {-remove leading blanks of string.}
  39.  
  40. FUNCTION RemoveTB(Instr:string):string;
  41. {-remove leading blanks of string}
  42.  
  43. FUNCTION Strip_blks(Instr:string):string;
  44. {-removes leading and trailing spaces of string.}
  45.  
  46. Function Locase(c:char):char;
  47. {-return the lower case of the alphabet}
  48.  
  49. function UpcaseStr(S : string) : string;
  50. {-UpcaseStr converts a string to upper case }
  51.  
  52. function LoCaseStr(S : string) : string;
  53. {- LoCaseStr converts a string to Lower case }
  54.  
  55. Function CapWords(S:string):string;
  56. {-capitalize the first letter of each word}
  57.  
  58. FUNCTION repeatchr(c:CHAR;l:INTEGER):string;
  59. {-generate L number of repeated characters}
  60.  
  61. function CenterStr(S : string; Width : Byte) : string;
  62. {- center a string (s) within N columns.}
  63.  
  64.  
  65. function CenterChr(S : string; Ch : Char; Width : Byte) : string;
  66. {- center a string (s) within N columns of char ch.}
  67.  
  68. Function IntStr(i : integer; f : shortint):str7;
  69. {- convert integer number to a string function 12/8/86}
  70. {- Input I - integer to convert, F-field format}
  71.  
  72. Function WordStr(i:word; f : shortint):str7;
  73. {- convert word number to a string function 12/8/86}
  74. {- Input I - word to convert, F-field format}
  75.  
  76.  
  77. Function LongIntStr(i : Longint; f : shortint):str10;
  78. {- convert longint number to a string function 9/21/88}
  79. {- Input I - longint to convert, F-field format}
  80.  
  81. function strint(s:str7):integer;
  82. {-convert a alphanumeric to a integer}
  83.  
  84. function strlongint(s:str25):Longint;
  85. {-convert a alphanumeric to a integer}
  86.  
  87. function strword(s:str7):word;
  88. {-convert a alphanumeric to a word}
  89.  
  90. function strreal(s:str20):real;
  91. {-convert a alphanumeric to a real}
  92.  
  93. function Substr(s:string; target:string; replace:string):string;
  94. {- substitute the "target" string with the "replace" string in string "s".
  95.  
  96.    ie s := 'HECTOR SANTOS';
  97.       s := substr(s,'HEC','SAN');
  98.       s => 'SANTOR SANTOS'
  99. }
  100.  
  101. FUNCTION removestring(s:string; target:string):string;
  102. {- Remove the "target" string from the input string "s".
  103.  
  104.    ie s := 'HECTOR SANTOS';
  105.       s := removestring(s,'HEC');
  106.       s => 'TOR SANTOS'
  107. }
  108.  
  109. Function First_non_Space(s:string):byte;
  110.  
  111. PROCEDURE SplitString(InStr:string; N : integer; VAR Out1,Out2:string);
  112. {
  113. SplitString : This Procedure will split a string (Instr) into two parts
  114.               (Out1, Out2).  Out1 will retain the length given by N minus
  115.               the amount so that the out1 does not end with a partial word.
  116.  
  117. }
  118.  
  119. Function Mat2Str(var mat; s : byte):string;
  120.  
  121. (* Pascal to ASCIIzed string conversion *)
  122.  
  123. procedure PasToZ(s: String);
  124.  
  125. {$V-}
  126. function nextword(var s : string):string;
  127. function strtoken(var s : string; Delimiters:string):string;
  128. {$V+}
  129.  
  130. Function RemoveBackSlash(s:string):string;
  131. function ForceExtension(Name, Ext : string) : string;
  132. function DefaultExtension(Name, Ext : string) : string;
  133. function HasExtension(Name : string; var DotPos : Word) : Boolean;
  134.  
  135. {===========================================================================}
  136.  
  137. Implementation
  138.  
  139. (* Pascal to ASCIIzed string conversion *)
  140.  
  141. procedure PasToZ(s: String);
  142.  
  143. var
  144.    n: Word;
  145. begin
  146.    n := Byte(s[0]);
  147.    if (n > 0) then
  148.    begin
  149.       Move(s[1],s[0],n);
  150.       s[n] := #0
  151.    end
  152. end;
  153.  
  154. FUNCTION RemoveLB(Instr:string):string;
  155. {-remove leading blanks}
  156.  
  157. VAR n : INTEGER;
  158. BEGIN
  159.  n := 1;
  160.  WHILE (instr[n]=' ') and (n < LENGTH(instr)) DO n := n+1;
  161.  RemoveLB := COPY(instr,n,length(instr));
  162. END; {end Function removelb}
  163.  
  164.  
  165. FUNCTION RemoveTB(Instr:string):string;
  166.  
  167. VAR n : INTEGER;
  168. BEGIN
  169. n := LENGTH(instr);
  170. WHILE instr[n]=' ' DO
  171.    BEGIN
  172.      instr := COPY(instr,1,n-1);
  173.      n := n-1;
  174.      IF n=0 then
  175.         begin
  176.          RemoveTb := '';
  177.          EXIT;
  178.         end;
  179.    END;
  180. RemoveTB:= instr;
  181. END; {end Function removetb}
  182.  
  183.  
  184. FUNCTION Strip_blks(Instr:string):string;
  185. {-removes leading and trailing spaces of string.}
  186.  
  187. BEGIN
  188.  strip_blks := Removelb(Removetb(instr));
  189. END; {end Function strip_blks}
  190.  
  191.  
  192.  
  193. Function Locase(c:char):char;
  194. {-return the lower case of the alphabet}
  195.  
  196. begin
  197.   locase := c;
  198.   if c in ['A'..'Z'] then locase := chr(ord(c)+32);
  199.  end;
  200.  
  201.  
  202. function UpcaseStr(S : string) : string;
  203. {-  UpcaseStr converts a string to upper case }
  204.  
  205. var
  206.   P : Integer;
  207. begin
  208.   for P := 1 to Length(S) do
  209.     S[P] := Upcase(S[P]);
  210.   UpcaseStr := S;
  211. end;
  212.  
  213.  
  214. function LoCaseStr(S : string) : string;
  215. {- LoCaseStr converts a string to Lower case }
  216.  
  217. var
  218.   P : Integer;
  219. begin
  220.   for P := 1 to Length(S) do
  221.     S[P] := LoCase(S[P]);
  222.   LoCaseStr := S;
  223. end;
  224.  
  225.  
  226. Function CapWords(S:string):string;
  227. {-capitalize the first letter of each word}
  228.  
  229. Var l : byte absolute s;
  230.     i : byte;
  231.     c : char;
  232.  begin
  233.    For i := 1 to l do
  234.       if s[i]<> ' ' then
  235.          If i=1
  236.             then s[i]:=Upcase(s[i])
  237.             else if s[i-1] in [' ','-']
  238.                     then s[i]:=Upcase(s[i])
  239.                     else s[i] := Locase(s[i]);
  240.    Capwords := s;
  241.  end;
  242.  
  243.  
  244. FUNCTION repeatchr(c:CHAR;l:INTEGER):string;
  245. {-generate L number of repeated characters}
  246.  
  247. VAR junk : string;
  248.     i    : INTEGER;
  249. BEGIN
  250. repeatchr := '';
  251. IF l<=0 then exit;
  252. junk [0] := chr(l);
  253. fillchar(junk[1],l,c);
  254. repeatchr := junk;
  255. END;
  256.  
  257.  
  258. function CenterChr(S : string; Ch : Char; Width : Byte) : string;
  259. {-Return a string centered in a string of Ch with specified width}
  260.   var
  261.     o : string;
  262.   begin
  263.     if Length(S) >= Width then
  264.       CenterChr := S
  265.     else begin
  266.       o[0] := Chr(Width);
  267.       FillChar(o[1], Width, Ch);
  268.       Move(S[1], o[Succ((Width-Length(S)) shr 1)], Length(S));
  269.       CenterChr := o;
  270.     end;
  271.   end;
  272.  
  273. function CenterStr(S : string; Width : Byte) : string;
  274.     {-Return a string centered in a blank string of specified width}
  275.   begin
  276.     CenterStr := CenterChr(S, ' ', Width);
  277.   end;
  278.  
  279.  
  280. Function IntStr(i : integer; f : shortint):str7;
  281. {- convert integer number to a string function 12/8/86}
  282. {- Input I - integer to convert, F-field format}
  283.  
  284. var e : integer; j : str6;
  285.  begin
  286.  j := '';
  287.  str(i:f,j);
  288.  IntStr := j;
  289. end;
  290.  
  291. Function WordStr(i :word; f : shortint):str7;
  292. {- convert word number to a string function 12/8/86}
  293. {- Input I - word to convert, F-field format}
  294.  
  295. var j : str7;
  296.  begin
  297.  j := '';
  298.  str(i:f,j);
  299.  WordStr := j;
  300. end;
  301.  
  302. Function LongIntStr(i : Longint; f : shortint):str10;
  303. {- convert longint number to a string function 9/21/88}
  304. {- Input I - longint to convert, F-field format}
  305.  
  306. var j : str10;
  307.  begin
  308.  j := '';
  309.  str(i:f,j);
  310.  LongIntStr := j;
  311. end;
  312.  
  313. function strint(s:str7):integer;
  314. {-convert a alphanumeric to a integer}
  315.  
  316. var i,err : integer;
  317.  
  318. begin
  319.  strint := 0;
  320.  val(s,i,err);
  321.  if err = 0 then strint := i;
  322. end;
  323.  
  324. function strlongint(s:str25):Longint;
  325. {-convert a alphanumeric to a Long integer}
  326.  
  327. var err : integer; i : longint;
  328.  
  329. begin
  330.  strLongint := 0;
  331.  val(s,i,err);
  332.  if err = 0 then strLongint := i;
  333. end;
  334.  
  335.  
  336. function strword(s:str7):word;
  337. {-convert a alphanumeric to a word}
  338.  
  339. var i   : word;
  340.     err : integer;
  341.  
  342. begin
  343.  strword := 0;
  344.  val(s,i,err);
  345.  if err = 0 then strword := i;
  346. end;
  347.  
  348.  
  349. function strreal(s:str20):real;
  350.  
  351. var err : integer;
  352.     i   : real;
  353.  
  354. begin
  355.  strreal := 0;
  356.  val(s,i,err);
  357.  if err = 0 then strreal := i;
  358. end;
  359.  
  360.  
  361.  
  362. FUNCTION SUBSTR(s:string; target:string; replace:string):string;
  363. {- substitute the "target" string with the "replace" string in string "s"}
  364.  
  365. {
  366.  IE  s := 'HECTOR SANTOS';
  367.       s := substr(s,'HEC','SAN');
  368.       s => 'SANTOR SANTOS'
  369. }
  370.  
  371.  
  372. VAR slen  : BYTE ABSOLUTE s;
  373.     tlen  : BYTE ABSOLUTE target;
  374.     rlen  : BYTE ABSOLUTE replace;
  375.     p     : INTEGER;
  376. BEGIN
  377. p := POS(target,s);
  378. substr := s;
  379. IF (p <> 0) AND ((slen-tLen+rlen)<=255)  {2nd condition checks for max len}
  380.    THEN BEGIN
  381.         DELETE(s,p,tlen);
  382.         INSERT(replace,s,p);
  383.         substr := s;
  384.         END;
  385. END; {end function substr}
  386.  
  387. FUNCTION removestring(s:string; target:string):string;
  388.  
  389. VAR slen  : BYTE ABSOLUTE s;
  390.     tlen  : BYTE ABSOLUTE target;
  391.     p     : INTEGER;
  392. BEGIN
  393. p := POS(target,s);
  394. removestring := s;
  395. IF (p <> 0)
  396.    THEN BEGIN
  397.         DELETE(s,p,tlen);
  398.         removestring := s;
  399.         END;
  400. END; {end function substr}
  401.  
  402. Function First_non_Space(s:string):byte;
  403.  var i : byte;
  404.   begin
  405.    First_non_space := 0;
  406.    if length(s) = 0 then exit;
  407.    i := 0;
  408.    while (s[i+1] = ' ') and ((i+1) < length(s)) do i:=i+1;
  409.    First_non_space := i;
  410.   end;
  411.  
  412.  
  413.  
  414.  
  415. PROCEDURE SplitString(InStr:string; N : integer; VAR Out1,Out2:string);
  416. {
  417. SplitString : This Procedure will split a string (Instr) into two parts
  418.               (Out1, Out2).  Out1 will retain the length given by N minus
  419.               the amount so that the out1 does not end with a partial word.
  420.  
  421. }
  422.  
  423. VAR I   : INTEGER;
  424.  
  425. BEGIN
  426. out1 := '*** Error In String Split ***';
  427. out2 := '*** Error In String Split ***';
  428. instr := RemoveTb(instr);
  429. i := n;
  430. if (n >= length(instr)) then
  431.    begin
  432.       out1 := instr;
  433.       out2 := '';
  434.       exit;
  435.    end;
  436.  
  437. WHILE (Instr[i]<>' ') AND (i<>0) DO i := i - 1;
  438. IF i<>0
  439.    THEN BEGIN
  440.         Out1 := COPY(instr,1,i);
  441.         Out2 := COPY(instr,i+1,LENGTH(instr));
  442.         END;
  443. END; {end splitstring}
  444.  
  445. Function Mat2Str(var mat; s : byte):string;
  446. {-convert s bytes in mat into a string}
  447. var i  : byte;
  448.     js : string;
  449. type
  450.    chars = array[1..maxint] of char;
  451.  begin
  452.    i := 1;
  453.    js := '';
  454.    while (i <= s) and ((chars(mat)[i]) <> chr(0)) do
  455.        begin
  456.          js := js + chars(mat)[i];
  457.          i := i +1;
  458.        end;
  459.  
  460.    Mat2str := js;
  461.  end;
  462.  
  463.  
  464. function nextword(var s : string):string;
  465. var p : byte;
  466.   begin
  467.     nextword := '';
  468.     s := strip_blks(s);
  469.     if length(s)=0 then exit;
  470.     p := pos(' ',s);
  471.     if p > 0
  472.      then begin nextword := copy(s,1,p-1); Delete(s,1,p); end
  473.      else begin nextword := s; s:= ''; end;
  474.   end;
  475.  
  476. function Strtoken(var s : string; delimiters:string):string;
  477. var p,b : byte;
  478.     vkeys : set of char;
  479.   begin
  480.     StrToken := '';
  481.     s := strip_blks(s);
  482.     if length(s)=0 then exit;
  483.     vkeys := [];
  484.     for p := 1 to length(delimiters) do vkeys := vkeys + [delimiters[p]];
  485.  
  486.     if s[1] in Vkeys then delete(s,1,1);
  487.  
  488.     for p := 1 to length(s) do
  489.        begin
  490.          if s[p] in vkeys then
  491.             begin
  492.                strtoken := copy(s,1,p-1);
  493.                Delete(s,1,p);
  494.                exit;
  495.             end;
  496.        end;
  497.     StrToken := S;
  498.     s        := '';
  499.   end;
  500.  
  501. Function RemoveBackSlash(s:string):string;
  502.   begin
  503.     if (s[length(s)] = '\') and (length(s) > 3) then
  504.        Delete(s,length(s),1);
  505.     RemovebackSlash := S;
  506.   End;
  507.  
  508. function HasExtension(Name : string; var DotPos : Word) : Boolean;
  509.   {-Return whether and position of extension separator dot in a pathname}
  510. var
  511.   I : Word;
  512. begin
  513.   DotPos := 0;
  514.   for I := Length(Name) downto 1 do
  515.     if (Name[I] = '.') and (DotPos = 0) then
  516.       DotPos := I;
  517.   HasExtension := (DotPos > 0) and (Pos('\', Copy(Name, Succ(DotPos), 64)) = 0);
  518. end;
  519.  
  520. function DefaultExtension(Name, Ext : string) : string;
  521.   {-Return a pathname with the specified extension attached}
  522. var
  523.   DotPos : Word;
  524. begin
  525.   if HasExtension(Name, DotPos) then
  526.     DefaultExtension := Name
  527.   else
  528.     DefaultExtension := Name+'.'+Ext;
  529. end;
  530.  
  531. function ForceExtension(Name, Ext : string) : string;
  532.   {-Return a pathname with the specified extension attached}
  533. var
  534.   DotPos : Word;
  535. begin
  536.   if HasExtension(Name, DotPos) then
  537.     ForceExtension := Copy(Name, 1, DotPos)+Ext
  538.   else
  539.     ForceExtension := Name+'.'+Ext;
  540. end;
  541.  
  542.  
  543. End.
  544.